C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C  ZLEGAL - TEST THE LEGALITY OF A FORTRAN VARIABLE NAME. TWO FORMS
C           OF LEGALITY ARE CHECKED; LEGALITY WITHIN THE STANDARD AND
C           LEGALITY ON THE LOCAL PROCESSOR.
C
      SUBROUTINE ZLEGAL (NAME, STDARD, LOCAL)
 
      INTEGER NAME(*), LENT, I
      INTEGER UPPCH(27), LOWCH(27), DIGCH(11), LGLCH(3), MAIN(6),
     +        BLOCK(11), COMN(8)
      LOGICAL STDARD, LOCAL
 
      INTEGER LENGTH,EQUAL,INDEXX
      EXTERNAL LENGTH,EQUAL,INDEXX
 
      DATA UPPCH/65,66,67,68,69,70,71,72,73,74,75,
     +           76,77,78,79,80,81,82,83,84,85,86,
     +           87,88,89,90,129/
      DATA LOWCH/97,98,99,100,101,102,103,104,105,106,107,
     +           108,109,110,111,112,113,114,115,116,117,118,
     +           119,120,121,122,129/
      DATA DIGCH/48,49,50,51,52,53,54,55,56,57,129/
      DATA LGLCH/36,95,129/
      DATA MAIN/36,77,65,73,78,129/,
     +     BLOCK/36,66,76,79,67,75,68,65,84,65,
     +129/,
     +     COMN/36,67,79,77,77,79,78,129/
 
      LENT = LENGTH(NAME)
C
C  FIRSTLY CHECK AGAINST THE FORTRAN STANDARD
C
      IF (EQUAL(NAME,MAIN).EQ.-2 .OR.
     +    EQUAL(NAME,BLOCK).EQ.-2 .OR.
     +    EQUAL(NAME,COMN).EQ.-2) THEN
C Unnamed main/blockdata/common are all ok.
        STDARD = .TRUE.
        LOCAL = .TRUE.
        RETURN
      END IF
      STDARD = .FALSE.
      IF(LENT .EQ. 0 .OR. LENT .GT. 6) GO TO 1000
      IF(INDEXX(UPPCH, NAME(1)) .EQ. 0) GO TO 1000
      I = 1
   10 CONTINUE
        I = I + 1
        IF(NAME(I) .NE. 129) THEN
          IF(INDEXX(UPPCH, NAME(I)) .NE. 0 .OR.
     +       INDEXX(DIGCH, NAME(I)) .NE. 0) GO TO 10
          GO TO 1000
        ENDIF
 
      STDARD = .TRUE.
C
C  NOW CHECK LOCAL LEGALITY - THIS VERSION WILL ALLOW THE NAME TO
C  BE UP TO 32 CHARACTERS LONG AND TO CONTAIN THE SYMBOLS '$' AND '_'
C
 1000 CONTINUE
      LOCAL = .FALSE.
      IF(LENT .EQ. 0 .OR. LENT .GT. 32) RETURN
      IF(INDEXX(UPPCH, NAME(1)) .EQ. 0 .AND.
     +   INDEXX(LOWCH, NAME(1)) .EQ. 0) RETURN
      I = 1
   20 CONTINUE
        I = I + 1
        IF(NAME(I) .NE. 129) THEN
          IF(INDEXX(UPPCH, NAME(I)) .NE. 0 .OR.
     +       INDEXX(LOWCH, NAME(I)) .NE. 0 .OR.
     +       INDEXX(DIGCH, NAME(I)) .NE. 0 .OR.
     +       INDEXX(LGLCH, NAME(I)) .NE. 0) GO TO 20
          RETURN
        ENDIF
 
      LOCAL = .TRUE.
 
      END
C---------------------------------------------------------
C  XSSSAS BASED ON ISTED/ADDSUB
C
C     CONCATENATE REPLACEMENT STRING FOR MATCHED PATTERN
C
      SUBROUTINE XSSSAS(LIN, FROM, TO, NEW, K, MAXNEW, PATSTR, REPSTR)
 
      INTEGER ADDSET, ZLOWER, ZUPPER
      INTEGER FROM, I, J, JUNK, K, MAXNEW, TO, STARTS, ENDS, C
      INTEGER LIN(*), NEW(*), PATSTR(*), REPSTR(*)
 
      I = 1
 
C     THE STRING 'NEW' ALREADY CONTAINS THE FIRST K-1 CHARACTERS OF 'LIN'
C     THE REPSTRSTITUTE STRING (TAG FIELDS AND ALL) IS PLACED IN NEW INSTEAD
C     OF THE CHARACTERS FROM-TO OF LIN
 
C     LOOP POINT
   10 CONTINUE
 
        IF(REPSTR(I) .EQ. 129) RETURN
 
        IF(REPSTR(I) .EQ. -101) THEN
 
          I  = I + 2
          IF(REPSTR(I) .NE. 0) THEN
            CALL XSSSGT(REPSTR(I), STARTS, ENDS, PATSTR)
          ELSE
            STARTS = FROM
            ENDS = TO
          ENDIF
          J = STARTS
   30     IF(J .GE. ENDS) GOTO 40
            IF(REPSTR(I-1) .EQ. 62) THEN
              C = ZUPPER(LIN(J))
            ELSE IF(REPSTR(I-1) .EQ. 60) THEN
              C = ZLOWER(LIN(J))
            ELSE
              C = LIN(J)
            ENDIF
            JUNK = ADDSET(C, NEW, K, MAXNEW)
            J=J+1
            GOTO 30
   40     CONTINUE
 
        ELSE
 
          JUNK = ADDSET(REPSTR(I), NEW, K, MAXNEW)
 
        ENDIF
 
        I = I + 1
 
      GOTO 10
 
      END
C----------------------------------
C  XISSAM BASED ON ISTED/AMATCH
C
C     FUNCTION TO LOOK FOR A PATTERN MATCH ALONG A LINE
C
      INTEGER FUNCTION XISSAM(LIN, FROM, PATSTR)
 
      INTEGER LIN(*), PATSTR(*)
      INTEGER XISSOM, XISSPS
      INTEGER FROM, I, J, OFFSET, STACK
C
C  XPSSPT - 05 June 1986
C           TIE LIBRARY
C           STRING SUPPLEMENTARY LIBRARY
C
C  Pattern matching parameters
C
 
      INTEGER  TAGSYM, CLOSYM, CL1SYM, ANYSYM, TRANSI, MAXPSZ,
     +         BOLSYM, EOLSYM, OTGSYM, CTGSYM, CCLSYM, CCESYM
 
      PARAMETER(TAGSYM = 38,     CLOSYM = 42,
     +          CL1SYM = 43,    ANYSYM = 63,
     +          TRANSI = 58,   BOLSYM = 37,
     +          EOLSYM = 36,  OTGSYM = 60,
     +          CTGSYM = 62, CCLSYM = 91,
     +          CCESYM = 93,  MAXPSZ = 256)
 
      STACK = 0
      OFFSET = FROM
      J = 13
 
   10 IF(PATSTR(J) .EQ. 129) GOTO 20
 
      IF(PATSTR(J) .EQ. CLOSYM) THEN
        STACK = J
        J = J + 4
        I = OFFSET
   40   IF(LIN(I) .EQ. 129) GOTO 50
        IF(XISSOM(LIN, I, J, PATSTR) .NE. -3) GOTO 40
   50   CONTINUE
        PATSTR(STACK + 1) = I - OFFSET
        PATSTR(STACK + 3) = OFFSET
        OFFSET = I
 
      ELSE IF(XISSOM(LIN, OFFSET, J, PATSTR) .EQ. -3) THEN
 
   60   IF(STACK .LE. 0) GOTO 30
          IF(PATSTR(STACK + 1) .GT. 0) GOTO 30
          STACK = PATSTR(STACK + 2)
        GO TO 60
 
   30   IF(STACK .LE. 0) THEN
          XISSAM = 0
          RETURN
        ENDIF
 
        PATSTR(STACK+1) = PATSTR(STACK+1) - 1
        J = STACK + 4
        OFFSET = PATSTR(STACK+3) + PATSTR(STACK+1)
      ENDIF
 
      J = J + XISSPS(J, PATSTR)
      GOTO 10
 
   20 CONTINUE
 
C     MATCH FOUND, RETURN POINTER TO END OF MATCH
      XISSAM = OFFSET
 
      END
C==================================
C
C  TAG FIELD ROUTINES
C
C==================================
C  XSSSCT BASED ON ISTED/CLRTAG
C
C  SUBROUTINE TO CLEAR TAG ARRAYS IN PREPERATION FOR PATTERN CREATION
C
      SUBROUTINE XSSSCT(STRING)
 
      INTEGER I, STRING(*)
 
C     CLEAR TAG FIELD START AND END POINTER ARRAYS
      DO 10 I = 2, 11
        STRING(I) = 0
   10 CONTINUE
 
C     SET INITIAL VALUES FOR CURRENT AND NEXT-FREE TAG FIELDS
      STRING(12) = 1
 
      END
C----------------------------------
C  XISSCT BASED ON ISTED/CLSTAG
C
C     FUNCTION TO CLOSE A TAG FIELD AND SAVE THE CURRENT POINTER VALUE
C
      INTEGER FUNCTION XISSCT(POINT, N, STRING)
 
      INTEGER POINT, N, STRING(*)
 
      IF((N .GE. 1) .AND. (N .LE. 9))  THEN
        STRING(N+2) = STRING(N+2)/256*256 + POINT
        XISSCT      = -2
      ELSE
        XISSCT = -1
      ENDIF
 
      END
C----------------------------------
C  XISSNX BASED ON ISTED/NXTTAG
C
C     FUNCTION TO RETURN AN INDEX TO THE NEXT FREE TAG FIELD IDENTIFIER
C
      INTEGER FUNCTION XISSNX(STRING)
 
      INTEGER STRING(*)
 
      IF(STRING(12) .GT. 9) THEN
        XISSNX = -1
 
      ELSE
        XISSNX = STRING(12)
        STRING(12) = STRING(12) + 1
 
      ENDIF
 
      END
C----------------------------------
C  XISSOP BASED ON ISTED/OPNTAG
C
C     FUNCTION TO OPEN A TAG FIELD AND SAVE THE START POSITION
C
      INTEGER FUNCTION XISSOP (POINT, N, STRING)
 
      INTEGER POINT, N, STRING(*)
 
      IF((N .GE. 1) .AND. (N .LE. 9)) THEN
C       SAVE CURRENT POINTER IN TAG FIELD ARRAY
        STRING(N + 2) = POINT * 256
        XISSOP = -2
 
      ELSE
C       ATTEMPT TO OPEN USING AN INVALID TAG FIELD NUMBER
        XISSOP = -1
 
      ENDIF
 
      END
C----------------------------------
C  XISSPR
C
C  FUNCTION TO RETURN THE VALUE OF THE CURRENT TAG FIELD TO
C  BE CLOSED. THE STORAGE LOCATION IN PATSTR IS USED TO HOLD
C  MARKERS TO INDICATE WHICH TAG FIELDS HAVE BEEN CLOSED
C  ALREADY, THESE MARKERS ARE CLEARED ON EXIT FROM ZCOMPP
C
      INTEGER FUNCTION XISSPR(PATSTR)
 
      INTEGER PATSTR(*)
 
      XISSPR = PATSTR(12) - 1
   10 CONTINUE
        IF(XISSPR .LE. 0) THEN
          XISSPR = -1
          RETURN
        ELSE
          IF(PATSTR(XISSPR+2) .NE. 0) THEN
            XISSPR = XISSPR - 1
            GO TO 10
          ELSE
            PATSTR(XISSPR+2) = 1
          ENDIF
        ENDIF
 
      END
C----------------------------------
C  XSSSGT BASED ON ISTED/GETTAG
C
      SUBROUTINE XSSSGT(POINT, START, END, STRING)
 
      INTEGER POINT, START, END, STRING(*)
 
      IF((POINT .GE. 1) .AND. (POINT .LE. 9)) THEN
        END   =  MOD(STRING(POINT+2), 256)
        START =  STRING(POINT+2)/256
 
      ELSE IF(POINT .EQ. 0) THEN
        END   =  MOD(STRING(2), 256)
        START =  STRING(2)/256
 
      ELSE
        START =  0
        END   =  0
 
      ENDIF
 
      END
C----------------------------------
C  XSSFLC
C
C  SAVE THE FIRST AND LAST CHARACTER POSITIONS FOR THE MATCH
C
      SUBROUTINE XSSFLC(START, END, STRING)
 
      INTEGER START, END, STRING(*)
 
      STRING(2) = (START * 256) + END
 
      END
C==================================
C----------------------------------
C  XSSSDO BASED ON ISTED/DODASH
C
C     SUBROUTINE TO EXPAND PATTERN CLASS RANGE
C
      SUBROUTINE XSSSDO(VALID, ARRAY, I, SET, J, MAXSET)
 
      INTEGER XISSEX
      INTEGER ADDSET, INDEXX
      INTEGER I, J, JUNK, K, LIMIT, MAXSET
      INTEGER ARRAY(*), SET(MAXSET), VALID(*)
 
      I = I + 1
      J = J - 1
      LIMIT = INDEXX(VALID, XISSEX(ARRAY, I))
 
      DO 10 K = INDEXX(VALID, SET(J)), LIMIT
        JUNK = ADDSET(VALID(K), SET, J, MAXSET)
   10 CONTINUE
 
      END
C----------------------------------
C  XISSEX BASED ON ISTED/EXPESC
C
C  UN-ESCAPE A SINGLE CHARACTER
C
      INTEGER FUNCTION XISSEX(ARRAY, I)
 
      INTEGER ARRAY(*)
      INTEGER I
 
      IF(ARRAY(I) .EQ. 64) THEN
        I = I + 1
        IF(ARRAY(I) .EQ. 110) THEN
          XISSEX = 10
          RETURN
        ELSE IF(ARRAY(I) .EQ. 116) THEN
          XISSEX = 9
          RETURN
        ENDIF
 
      ENDIF
 
      XISSEX = ARRAY(I)
 
      END
C----------------------------------
C  XSSSFI BASED ON ISTED/FILSET
C
C     SUBROUTINE TO FILL A CHARACTER CLASS SET FOR PATTERN MATCHING
C
      SUBROUTINE XSSSFI(DELIM, ARRAY, I, SET, J, MAXSET)
 
      INTEGER ADDSET, INDEXX, XISSEX
      INTEGER I, J, JUNK, MAXSET, DELIM
      INTEGER ARRAY(*), SET(*), DIGITS(11), LOWALF(27), UPALF(27)
      SAVE
 
      DATA DIGITS /48, 49, 50, 51, 52, 53,
     +             54, 55, 56, 57, 129/
      DATA LOWALF /97, 98, 99, 100, 101, 102, 103, 104, 105,
     +             106, 107, 108, 109, 110, 111, 112, 113, 114,
     +             115, 116, 117, 118, 119, 120, 121, 122, 129/
      DATA UPALF  /65, 66, 67, 68, 69, 70, 71, 72, 73,
     +             74, 75, 76, 77, 78, 79, 80, 81, 82,
     +             83, 84, 85, 86, 87, 88, 89, 90, 129/
 
   10 IF((ARRAY(I) .EQ. DELIM) .OR. (ARRAY(I) .EQ. 129)) RETURN
 
      IF(ARRAY(I) .EQ. 64) THEN
 
C       CHARACTER HAS BEEN ESCAPED
        JUNK = ADDSET(XISSEX(ARRAY, I), SET, J, MAXSET)
      ELSE IF(ARRAY(I) .NE. 45) THEN
 
C
        JUNK = ADDSET(ARRAY(I), SET, J, MAXSET)
      ELSE IF(J .LE. 1 .OR. ARRAY(I+1) .EQ. 129) THEN
 
        JUNK = ADDSET(45, SET, J, MAXSET)
      ELSE IF(INDEXX(DIGITS, SET(J-1)) .GT. 0) THEN
 
        CALL XSSSDO(DIGITS, ARRAY, I, SET, J, MAXSET)
      ELSE IF(INDEXX(LOWALF, SET(J-1)) .GT. 0) THEN
 
        CALL XSSSDO(LOWALF, ARRAY, I, SET, J, MAXSET)
      ELSE IF(INDEXX(UPALF, SET(J-1)) .GT. 0) THEN
 
        CALL XSSSDO(UPALF, ARRAY, I, SET, J, MAXSET)
      ELSE
 
 
        JUNK = ADDSET(45, SET, J, MAXSET)
      ENDIF
 
      I = I + 1
 
      GOTO 10
 
      END
C----------------------------------
C  XISSGC BASED ON ISTED/GETCCL
C
C    FUNCTION TO GET CHARACTER CLASS
C
      INTEGER FUNCTION XISSGC(ARG, I, PAT, J)
 
      INTEGER ARG(*), PAT(*)
      INTEGER ADDSET
      INTEGER I, J, JSTART, JUNK
 
C
C  XPSSPT - 05 June 1986
C           TIE LIBRARY
C           STRING SUPPLEMENTARY LIBRARY
C
C  Pattern matching parameters
C
 
      INTEGER  TAGSYM, CLOSYM, CL1SYM, ANYSYM, TRANSI, MAXPSZ,
     +         BOLSYM, EOLSYM, OTGSYM, CTGSYM, CCLSYM, CCESYM
 
      PARAMETER(TAGSYM = 38,     CLOSYM = 42,
     +          CL1SYM = 43,    ANYSYM = 63,
     +          TRANSI = 58,   BOLSYM = 37,
     +          EOLSYM = 36,  OTGSYM = 60,
     +          CTGSYM = 62, CCLSYM = 91,
     +          CCESYM = 93,  MAXPSZ = 256)
 
      I = I + 1
 
C     CHECK IF AN INCLUSIVE OR EXCLUSIVE SET IS BEING REQUESTED
      IF(ARG(I) .EQ. 126)  THEN
        JUNK = ADDSET(CCESYM, PAT, J, MAXPSZ)
        I = I + 1
      ELSE
        JUNK = ADDSET(CCLSYM, PAT, J, MAXPSZ)
      ENDIF
 
C     SET UP CLASS ENTRY, INCLUDING MOCK STACK VALUE (INITIALLY 0)
      JSTART = J
      JUNK = ADDSET(0, PAT, J, MAXPSZ)
      CALL XSSSFI(CCESYM, ARG, I, PAT, J, MAXPSZ)
      PAT(JSTART) = J - JSTART - 1
 
C     CHECK TO SEE IF PATTERN FILLED IN OK
      IF(ARG(I) .EQ. CCESYM) THEN
        XISSGC = -2
      ELSE
        XISSGC = -1
      ENDIF
 
      END
C----------------------------------
C  XISSLO BASED ON ISTED/LOCATE
C
      INTEGER FUNCTION XISSLO(C, PAT, OFFSET)
 
      INTEGER PAT(*)
      INTEGER I, OFFSET, C
 
      I = OFFSET + PAT(OFFSET)
 
   10 IF(I .LE. OFFSET) GOTO 20
 
        IF(C .EQ. PAT(I)) THEN
          XISSLO = -2
          RETURN
        ENDIF
        I = I - 1
 
      GOTO 10
 
   20 CONTINUE
      XISSLO = -3
 
      END
C----------------------------------
C  XISSOM  BASED ON ISTED/OMAT
C
C     FUNCTION TO MATCH A SINGLE PATTERN
C
      INTEGER FUNCTION XISSOM(LIN, I, J, PATSTR)
 
      INTEGER LIN(*), PATSTR(*)
      INTEGER XISSOP, XISSCT, ZLOWER, TYPE
      INTEGER STATE1, STATE2
      INTEGER XISSLO
      INTEGER BUMP, I, J, JUNK
C
C  XPSSPT - 05 June 1986
C           TIE LIBRARY
C           STRING SUPPLEMENTARY LIBRARY
C
C  Pattern matching parameters
C
 
      INTEGER  TAGSYM, CLOSYM, CL1SYM, ANYSYM, TRANSI, MAXPSZ,
     +         BOLSYM, EOLSYM, OTGSYM, CTGSYM, CCLSYM, CCESYM
 
      PARAMETER(TAGSYM = 38,     CLOSYM = 42,
     +          CL1SYM = 43,    ANYSYM = 63,
     +          TRANSI = 58,   BOLSYM = 37,
     +          EOLSYM = 36,  OTGSYM = 60,
     +          CTGSYM = 62, CCLSYM = 91,
     +          CCESYM = 93,  MAXPSZ = 256)
 
C     A NULL STRING DOES NOT MATCH
      XISSOM = -3
 
C     SET INITIAL (INVALID) VALUE FOR POINTER UPDATE
      BUMP = -1
 
C     ORDINARY CHARACTER
      IF(PATSTR(J) .EQ. 97) THEN
        IF(PATSTR(1) .EQ. 1) THEN
          IF(ZLOWER(LIN(I)) .EQ. ZLOWER(PATSTR(J + 1))) BUMP = 1
        ELSE
          IF(LIN(I) .EQ. PATSTR(J + 1)) BUMP = 1
        ENDIF
 
C     BEGINNING OF THE LINE
      ELSE IF(PATSTR(J) .EQ. BOLSYM) THEN
        IF(I .EQ. 1) BUMP = 0
 
C     FREE MATCH (ANY CHARACTER)
      ELSE IF(PATSTR(J) .EQ. 63) THEN
        IF(LIN(I) .NE. 10 .AND. LIN(I) .NE. 129) BUMP = 1
 
C     TRANSITION
      ELSE IF(PATSTR(J) .EQ. TRANSI) THEN
        IF(I .GT. 1) THEN
          STATE1 = TYPE(LIN(I-1))
          STATE2 = TYPE(LIN(I))
          IF(STATE1 .EQ. 2) STATE1 = 1
          IF(STATE2 .EQ. 2) STATE2 = 1
          IF(STATE1 .NE. 1) STATE1 = 48
          IF(STATE2 .NE. 1) STATE2 = 48
          IF(STATE1 .NE. STATE2) BUMP = 0
        ENDIF
 
C     END OF THE LINE
      ELSE IF(PATSTR(J) .EQ. EOLSYM) THEN
        IF((LIN(I) .EQ. 10) .OR. (LIN(I) .EQ. 129)) BUMP = 0
 
C     CHARACTER CLASS
      ELSE IF(PATSTR(J) .EQ. CCLSYM) THEN
        IF(XISSLO(LIN(I), PATSTR, J + 1) .EQ. -2) BUMP = 1
 
C     NEGATED CHARACTER CLASS
      ELSE IF(PATSTR(J) .EQ. CCESYM) THEN
        IF((LIN(I) .NE. 10) .AND. (LIN(I) .NE. 129)
     +    .AND. XISSLO(LIN(I), PATSTR, J + 1) .EQ. -3)  BUMP = 1
 
C     OPEN TAG FIELD
      ELSE IF(PATSTR(J) .EQ. OTGSYM) THEN
        BUMP = 0
        JUNK = XISSOP(I, PATSTR(J+1), PATSTR)
 
C     CLOSE TAG FIELD
      ELSE IF(PATSTR(J) .EQ. CTGSYM) THEN
        BUMP = 0
        JUNK = XISSCT(I, PATSTR(J+1), PATSTR)
 
      ENDIF
 
C     IF BUMP IS NO LONGER -1 THEN A MATCH HAS BEEN FOUND
      IF(BUMP .GE. 0) THEN
        I = I + BUMP
        XISSOM = -2
      ENDIF
 
      END
C----------------------------------
C  XISSPS BASED ON ISTED/PTSIZE
C
      INTEGER FUNCTION XISSPS(N, PATSTR)
 
      INTEGER N, PATSTR(*)
C
C  XPSSPT - 05 June 1986
C           TIE LIBRARY
C           STRING SUPPLEMENTARY LIBRARY
C
C  Pattern matching parameters
C
 
      INTEGER  TAGSYM, CLOSYM, CL1SYM, ANYSYM, TRANSI, MAXPSZ,
     +         BOLSYM, EOLSYM, OTGSYM, CTGSYM, CCLSYM, CCESYM
 
      PARAMETER(TAGSYM = 38,     CLOSYM = 42,
     +          CL1SYM = 43,    ANYSYM = 63,
     +          TRANSI = 58,   BOLSYM = 37,
     +          EOLSYM = 36,  OTGSYM = 60,
     +          CTGSYM = 62, CCLSYM = 91,
     +          CCESYM = 93,  MAXPSZ = 256)
 
      IF(PATSTR(N) .EQ. 97) THEN
        XISSPS = 2
 
      ELSE IF(PATSTR(N) .EQ. BOLSYM .OR. PATSTR(N) .EQ. EOLSYM
     +        .OR. PATSTR(N) .EQ. 63 .OR. PATSTR(N) .EQ. TRANSI) THEN
        XISSPS = 1
 
      ELSE IF(PATSTR(N) .EQ. CCLSYM .OR. PATSTR(N) .EQ. CCESYM) THEN
        XISSPS = PATSTR(N + 1) + 2
 
      ELSE IF(PATSTR(N) .EQ. CLOSYM) THEN
        XISSPS = 4
 
      ELSE IF(PATSTR(N) .EQ. OTGSYM .OR. PATSTR(N) .EQ. CTGSYM) THEN
        XISSPS = 2
 
      ENDIF
 
      END
C----------------------------------
C  XISSSC BASED ON ISTED/STCLOS
C
C ADD A CLOSURE PATTERN TO THE MATCH PATTERN
C CLOSURE ENTRY SIZE = 4
C              COUNT = 1
C             PREVCL = 2
C              START = 3
C
      INTEGER FUNCTION XISSSC(PAT, J, LASTJ, LASTCL)
 
      INTEGER PAT(*)
      INTEGER ADDSET
      INTEGER J, JP, JT, JUNK, LASTCL, LASTJ
C
C  XPSSPT - 05 June 1986
C           TIE LIBRARY
C           STRING SUPPLEMENTARY LIBRARY
C
C  Pattern matching parameters
C
 
      INTEGER  TAGSYM, CLOSYM, CL1SYM, ANYSYM, TRANSI, MAXPSZ,
     +         BOLSYM, EOLSYM, OTGSYM, CTGSYM, CCLSYM, CCESYM
 
      PARAMETER(TAGSYM = 38,     CLOSYM = 42,
     +          CL1SYM = 43,    ANYSYM = 63,
     +          TRANSI = 58,   BOLSYM = 37,
     +          EOLSYM = 36,  OTGSYM = 60,
     +          CTGSYM = 62, CCLSYM = 91,
     +          CCESYM = 93,  MAXPSZ = 256)
 
      DO 10 JP = J-1, LASTJ, -1
        JT = JP + 4
        JUNK = ADDSET(PAT(JP), PAT, JT, MAXPSZ)
   10 CONTINUE
 
      J = J + 4
      XISSSC = LASTJ
 
      JUNK = ADDSET(CLOSYM, PAT, LASTJ, MAXPSZ)
      JUNK = ADDSET(0, PAT, LASTJ, MAXPSZ)
      JUNK = ADDSET(LASTCL, PAT, LASTJ, MAXPSZ)
      JUNK = ADDSET(0, PAT, LASTJ, MAXPSZ)
 
      END
C==================================
C
C  USER CALLABLE ROUTINES
C
C==================================
C
C  ZCOMPP  - 9 OCT 86
C            TIE LIBRARY
C            STRING SUPPLEMENTARY LIBRARY
C
C  SET THE SPECIFIED PATTERN INTO THE COMMON BLOCK IN THE
C  FORM USED BY THE PATTERN MATCHING ROUTINE
C
      INTEGER FUNCTION ZCOMPP(STRING, FLAG, PATSTR)
 
      LOGICAL  FLAG
      INTEGER  I, J, JUNK, LASTCL, LASTJ, LJ
      INTEGER  STRING(*), PATSTR(*)
      INTEGER  ADDSET, XISSGC, XISSSC, XISSPR, XISSNX, XISSEX
C
C  XPSSPT - 05 June 1986
C           TIE LIBRARY
C           STRING SUPPLEMENTARY LIBRARY
C
C  Pattern matching parameters
C
 
      INTEGER  TAGSYM, CLOSYM, CL1SYM, ANYSYM, TRANSI, MAXPSZ,
     +         BOLSYM, EOLSYM, OTGSYM, CTGSYM, CCLSYM, CCESYM
 
      PARAMETER(TAGSYM = 38,     CLOSYM = 42,
     +          CL1SYM = 43,    ANYSYM = 63,
     +          TRANSI = 58,   BOLSYM = 37,
     +          EOLSYM = 36,  OTGSYM = 60,
     +          CTGSYM = 62, CCLSYM = 91,
     +          CCESYM = 93,  MAXPSZ = 256)
 
      CALL XSSSCT(PATSTR)
      PATSTR(1) = 0
      IF(FLAG) PATSTR(1) = 1
 
      J = 13
      LASTJ = 1
      LASTCL = 0
      I = 1
 
   20 IF(STRING(I) .EQ. 129) GO TO 10
 
        LJ = J
 
        IF(STRING(I) .EQ. ANYSYM) THEN
          JUNK = ADDSET(63, PATSTR, J, MAXPSZ)
 
        ELSE IF(STRING(I) .EQ. TRANSI) THEN
          JUNK = ADDSET(TRANSI, PATSTR, J, MAXPSZ)
 
        ELSE IF(STRING(I) .EQ. BOLSYM .AND. I .EQ. 1) THEN
          JUNK = ADDSET(BOLSYM, PATSTR, J, MAXPSZ)
 
        ELSE IF(STRING(I) .EQ. EOLSYM .AND. STRING(I + 1) .EQ. 129) THEN
          JUNK = ADDSET(EOLSYM, PATSTR, J, MAXPSZ)
 
        ELSE IF(STRING(I) .EQ. CCLSYM) THEN
          IF(XISSGC(STRING, I, PATSTR, J) .EQ. -1) GOTO 10
 
        ELSE IF((STRING(I) .EQ. CLOSYM .OR. STRING(I) .EQ. CL1SYM)
     +          .AND. I .GT. 1) THEN
          LJ = LASTJ
          IF(PATSTR(LJ) .EQ. BOLSYM .OR. PATSTR(LJ) .EQ. EOLSYM .OR.
     +       PATSTR(LJ) .EQ. CLOSYM .OR. PATSTR(LJ) .EQ. CL1SYM) GOTO 10
          IF(STRING(I) .EQ. CL1SYM) THEN
            LASTJ = J
   40       IF(LJ .GE. LASTJ) GOTO 30
              JUNK = ADDSET(PATSTR(LJ), PATSTR, J, MAXPSZ)
              LJ = LJ + 1
            GOTO 40
          ENDIF
   30     LASTCL = XISSSC(PATSTR, J, LASTJ, LASTCL)
 
        ELSE IF(STRING(I) .EQ. OTGSYM) THEN
 
          ZCOMPP = XISSNX(PATSTR)
          IF(ZCOMPP .EQ. -1) RETURN
          JUNK = ADDSET(OTGSYM, PATSTR, J, MAXPSZ)
          JUNK = ADDSET(ZCOMPP, PATSTR, J, MAXPSZ)
 
        ELSE IF(STRING(I) .EQ. CTGSYM) THEN
 
          ZCOMPP = XISSPR(PATSTR)
          IF(ZCOMPP .EQ. -1) RETURN
          JUNK = ADDSET(CTGSYM, PATSTR, J, MAXPSZ)
          JUNK = ADDSET(ZCOMPP, PATSTR, J, MAXPSZ)
 
        ELSE
 
          JUNK = ADDSET(97, PATSTR, J, MAXPSZ)
          JUNK = ADDSET(XISSEX(STRING, I), PATSTR, J, MAXPSZ)
 
        ENDIF
 
      LASTJ = LJ
      I = I + 1
      GOTO 20
 
   10 CONTINUE
      CALL XSSSCT(PATSTR)
      ZCOMPP = -2
      IF(I .EQ. 1) RETURN
 
      IF(STRING(I) .NE. 129) THEN
        ZCOMPP = -1
      ELSE IF(ADDSET(129, PATSTR, J, MAXPSZ) .EQ. -3) THEN
        ZCOMPP = -1
      ENDIF
 
      END
C----------------------------------
C
C  ZMATCH  - 9 OCT 86
C            TIE LIBRARY
C            STRING SUPPLEMENTARY LIBRARY
C
C  MATCH THE PATTERN AGAINST THE PROVIDED LINE
C
      INTEGER FUNCTION ZMATCH(STRING, FROM, START, END, PATSTR)
 
      INTEGER  STRING(*), PATSTR(*)
      INTEGER  FROM, START, END, I, N
      INTEGER  XISSAM
 
      ZMATCH = -3
 
C     LOOP ALONG THE LINE UNTIL A MATCH IS FOUND, OR AN EOS IS ENCOUNTERED
      DO 10 I = FROM, 132
 
C       NO MATCH FOUND
        IF(STRING(I) .EQ. 129) RETURN
 
        N = XISSAM(STRING, I, PATSTR)
 
        IF(N .GT. 0) THEN
          ZMATCH = -2
          START  = I
          END    = N - 1
          RETURN
        ENDIF
 
   10 CONTINUE
 
      END
C----------------------------------
C
C  ZREPLS  - 9 OCT 86
C            TIE LIBRARY
C            STRING SUPPLEMENTARY LIBRARY
C
C  SET THE SPECIFIED REPLACEMENT PATTERN INTO THE COMMON BLOCK
C
      INTEGER FUNCTION ZREPLS(STRING, REPSTR)
 
      INTEGER STRING(*), REPSTR(*)
      INTEGER DIGITS(10)
      INTEGER ADDSET, INDEXX, XISSEX
      INTEGER I, J, JUNK, N, POINT, TYPE
C
C  XPSSPT - 05 June 1986
C           TIE LIBRARY
C           STRING SUPPLEMENTARY LIBRARY
C
C  Pattern matching parameters
C
 
      INTEGER  TAGSYM, CLOSYM, CL1SYM, ANYSYM, TRANSI, MAXPSZ,
     +         BOLSYM, EOLSYM, OTGSYM, CTGSYM, CCLSYM, CCESYM
 
      PARAMETER(TAGSYM = 38,     CLOSYM = 42,
     +          CL1SYM = 43,    ANYSYM = 63,
     +          TRANSI = 58,   BOLSYM = 37,
     +          EOLSYM = 36,  OTGSYM = 60,
     +          CTGSYM = 62, CCLSYM = 91,
     +          CCESYM = 93,  MAXPSZ = 256)
 
      DATA DIGITS /49, 50, 51, 52, 53,
     +             54, 55, 56, 57, 129/
 
      J = 1
      I = 1
   20 IF(STRING(I) .EQ. 129) GO TO 10
 
        IF(STRING(I) .EQ. TAGSYM) THEN
 
C         LOOK FOR A CASE CHANGE REQUEST
          TYPE = 61
          IF(STRING(I + 1) .EQ. 62) THEN
            TYPE = 62
            I = I + 1
          ELSE IF(STRING(I + 1) .EQ. 60) THEN
            TYPE = 60
            I = I + 1
          ENDIF
 
          POINT = I + 1
          N = INDEXX(DIGITS, STRING(POINT))
 
          IF( N .NE. 0) THEN
            JUNK = ADDSET(-101, REPSTR,J, 132)
            JUNK = ADDSET(TYPE, REPSTR, J, 132)
            JUNK = ADDSET(N, REPSTR, J, 132)
            I = I + 1
          ELSE
            JUNK = ADDSET(-101, REPSTR, J, 132)
            JUNK = ADDSET(TYPE, REPSTR, J, 132)
            JUNK = ADDSET(0, REPSTR, J, 132)
            IF(STRING(POINT) .EQ. 48) I = I + 1
          ENDIF
 
        ELSE
 
          JUNK = ADDSET(XISSEX(STRING, I), REPSTR, J, 132)
 
        ENDIF
        I = I + 1
 
      GOTO 20
 
   10 CONTINUE
      IF(ADDSET(129, REPSTR, J, 132) .EQ. -3) THEN
        ZREPLS = -1
      ELSE
        ZREPLS = -2
      ENDIF
 
      END
C----------------------------------
C
C  ZSTRRP  - 9 OCT 86
C            TIE LIBRARY
C            STRING SUPPLEMENTARY LIBRARY
C
C  PERFORM A STRING REPLACEMENT
C
      INTEGER FUNCTION ZSTRRP(STRNG1, STRNG2, GLOBAL, PATSTR, REPSTR)
 
      INTEGER STRNG1(*), STRNG2(*), PATSTR(*), REPSTR(*)
      INTEGER J, JUNK, K, LASTM, M, SUBBED
      LOGICAL GLOBAL
      INTEGER  ADDSET, XISSAM, LENGTH
 
      ZSTRRP = -1
      J = 1
      SUBBED = -3
      LASTM = 0
      K = 1
 
      IF(LENGTH(STRNG1) .GE. K) THEN
   10   CONTINUE
        IF(STRNG1(K) .NE. 129) THEN
          IF(GLOBAL .OR. (SUBBED .EQ. -3)) THEN
            M = XISSAM(STRNG1, K, PATSTR)
          ELSE
            M = 0
          ENDIF
          IF(M .GT. 0 .AND. LASTM .NE. M) THEN
            SUBBED = -2
            CALL XSSFLC(K, M, PATSTR)
            CALL XSSSAS(STRNG1, K, M, STRNG2, J, 132, PATSTR, REPSTR)
            LASTM = M
          ENDIF
          IF((M .EQ. 0) .OR.( M .EQ. K)) THEN
            JUNK = ADDSET(STRNG1(K), STRNG2, J, 132)
            K = K + 1
          ELSE
            K = M
          END IF
          GOTO 10
        END IF
      END IF
      IF(SUBBED .EQ. -2) THEN
        IF(ADDSET(129, STRNG2, J, 132) .EQ. -3) RETURN
        ZSTRRP = -2
      ENDIF
 
      END
C==================================
C
C  OLD USER CALLABLE ROUTINES
C
C==================================
C
C  ZSETP   - 9 OCT 86
C            TIE LIBRARY
C            STRING SUPPLEMENTARY LIBRARY
C
C  SET THE SPECIFIED PATTERN INTO THE COMMON BLOCK IN THE
C  FORM USED BY THE PATTERN MATCHING ROUTINE
C
      INTEGER FUNCTION ZSETP (STRING, FLAG)
 
      LOGICAL  FLAG
      INTEGER  STRING(*)
      INTEGER  ZCOMPP
C
C  XPSSPT - 05 June 1986
C           TIE LIBRARY
C           STRING SUPPLEMENTARY LIBRARY
C
C  Pattern matching parameters
C
 
      INTEGER  TAGSYM, CLOSYM, CL1SYM, ANYSYM, TRANSI, MAXPSZ,
     +         BOLSYM, EOLSYM, OTGSYM, CTGSYM, CCLSYM, CCESYM
 
      PARAMETER(TAGSYM = 38,     CLOSYM = 42,
     +          CL1SYM = 43,    ANYSYM = 63,
     +          TRANSI = 58,   BOLSYM = 37,
     +          EOLSYM = 36,  OTGSYM = 60,
     +          CTGSYM = 62, CCLSYM = 91,
     +          CCESYM = 93,  MAXPSZ = 256)
C
C  XCSSPT - 9 OCT 86
C           TIE LIBRARY
C           STRING SUPPLEMENTARY LIBRARY
C
C  PATTERN MATCHING COMMON BLOCK
 
      INTEGER  SAVPAT(MAXPSZ),  SAVREP(134)
 
      COMMON /XCSSPT/ SAVPAT, SAVREP
      SAVE
 
      ZSETP = ZCOMPP(STRING, FLAG, SAVPAT)
 
      END
C----------------------------------
C
C  ZPFIND  - 9 OCT 86
C            TIE LIBRARY
C            STRING SUPPLEMENTARY LIBRARY
C
C  MATCH THE STORED PATTERN AGAINST THE PROVIDED LINE
C
      INTEGER FUNCTION ZPFIND(STRING, FROM, START, END)
 
      INTEGER  STRING(*)
      INTEGER  FROM, START, END, I, N
      INTEGER  ZMATCH
C
C  XPSSPT - 05 June 1986
C           TIE LIBRARY
C           STRING SUPPLEMENTARY LIBRARY
C
C  Pattern matching parameters
C
 
      INTEGER  TAGSYM, CLOSYM, CL1SYM, ANYSYM, TRANSI, MAXPSZ,
     +         BOLSYM, EOLSYM, OTGSYM, CTGSYM, CCLSYM, CCESYM
 
      PARAMETER(TAGSYM = 38,     CLOSYM = 42,
     +          CL1SYM = 43,    ANYSYM = 63,
     +          TRANSI = 58,   BOLSYM = 37,
     +          EOLSYM = 36,  OTGSYM = 60,
     +          CTGSYM = 62, CCLSYM = 91,
     +          CCESYM = 93,  MAXPSZ = 256)
C
C  XCSSPT - 9 OCT 86
C           TIE LIBRARY
C           STRING SUPPLEMENTARY LIBRARY
C
C  PATTERN MATCHING COMMON BLOCK
 
      INTEGER  SAVPAT(MAXPSZ),  SAVREP(134)
 
      COMMON /XCSSPT/ SAVPAT, SAVREP
      SAVE
 
      ZPFIND = ZMATCH(STRING, FROM, START, END, SAVPAT)
 
      END
C----------------------------------
C
C  ZSETR   - 9 OCT 86
C            TIE LIBRARY
C            STRING SUPPLEMENTARY LIBRARY
C
C  SET THE SPECIFIED REPLACEMENT PATTERN INTO THE COMMON BLOCK
C
      INTEGER FUNCTION ZSETR (STRING)
 
      INTEGER STRING(*)
      INTEGER ZREPLS
C
C  XPSSPT - 05 June 1986
C           TIE LIBRARY
C           STRING SUPPLEMENTARY LIBRARY
C
C  Pattern matching parameters
C
 
      INTEGER  TAGSYM, CLOSYM, CL1SYM, ANYSYM, TRANSI, MAXPSZ,
     +         BOLSYM, EOLSYM, OTGSYM, CTGSYM, CCLSYM, CCESYM
 
      PARAMETER(TAGSYM = 38,     CLOSYM = 42,
     +          CL1SYM = 43,    ANYSYM = 63,
     +          TRANSI = 58,   BOLSYM = 37,
     +          EOLSYM = 36,  OTGSYM = 60,
     +          CTGSYM = 62, CCLSYM = 91,
     +          CCESYM = 93,  MAXPSZ = 256)
C
C  XCSSPT - 9 OCT 86
C           TIE LIBRARY
C           STRING SUPPLEMENTARY LIBRARY
C
C  PATTERN MATCHING COMMON BLOCK
 
      INTEGER  SAVPAT(MAXPSZ),  SAVREP(134)
 
      COMMON /XCSSPT/ SAVPAT, SAVREP
      SAVE
 
      ZSETR = ZREPLS(STRING, SAVREP)
 
      END
C----------------------------------
C
C  ZPREPL  - 9 OCT 86
C            TIE LIBRARY
C            STRING SUPPLEMENTARY LIBRARY
C
C  PERFORM A STRING REPLACEMENT
C
      INTEGER FUNCTION ZPREPL(STRNG1, STRNG2, GLOBAL)
 
      INTEGER STRNG1(*), STRNG2(*)
      LOGICAL GLOBAL
C
C  XPSSPT - 05 June 1986
C           TIE LIBRARY
C           STRING SUPPLEMENTARY LIBRARY
C
C  Pattern matching parameters
C
 
      INTEGER  TAGSYM, CLOSYM, CL1SYM, ANYSYM, TRANSI, MAXPSZ,
     +         BOLSYM, EOLSYM, OTGSYM, CTGSYM, CCLSYM, CCESYM
 
      PARAMETER(TAGSYM = 38,     CLOSYM = 42,
     +          CL1SYM = 43,    ANYSYM = 63,
     +          TRANSI = 58,   BOLSYM = 37,
     +          EOLSYM = 36,  OTGSYM = 60,
     +          CTGSYM = 62, CCLSYM = 91,
     +          CCESYM = 93,  MAXPSZ = 256)
C
C  XCSSPT - 9 OCT 86
C           TIE LIBRARY
C           STRING SUPPLEMENTARY LIBRARY
C
C  PATTERN MATCHING COMMON BLOCK
 
      INTEGER  SAVPAT(MAXPSZ),  SAVREP(134)
 
      COMMON /XCSSPT/ SAVPAT, SAVREP
      SAVE
      INTEGER  ZSTRRP
 
      ZPREPL = ZSTRRP(STRNG1, STRNG2, GLOBAL, SAVPAT, SAVREP)
 
      END
C----------------------------------
C
C  ZSEDID  - 26 JAN 84
C            TIE LIBRARY
C            STRING SUPPLEMENTARY LIBRARY
C
C  LOOK FOR A SOURCE EMBEDDED DIRECTIVE (SED)
C
      INTEGER FUNCTION ZSEDID(LINE, BIND, ID, BODY)
 
      INTEGER  BIND, I
      INTEGER  LINE(*), ID(*), BODY(*)
      INTEGER  ZLOWER, LENGTH
      EXTERNAL ZLOWER, SCOPY, SKIPBL, LENGTH
 
      ZSEDID = -3
      BIND   = 32
 
C  A SED MUST START WITH A '*' IN COLUMN 1
      IF(LINE(1) .NE. 42) RETURN
 
      I = 2
      CALL SKIPBL(LINE, I)
 
      IF((LINE(I) .NE. 36) .OR. (LINE(I+3) .NE. 36)) RETURN
      ID(1) = ZLOWER(LINE(I + 1))
      ID(2) = ZLOWER(LINE(I + 2))
      ID(3) = 129
 
      ZSEDID = -2
 
      I = I + 4
      CALL SKIPBL(LINE, I)
      CALL SCOPY(LINE, I, BODY, 1)
 
C  STRIP OFF TRAILING IN-LINE COMMENTS
      DO 10 I = 1, 132
        IF(BODY(I) .EQ. 129) RETURN
        IF(BODY(I) .EQ. 33) THEN
          IF(BODY(LENGTH(BODY)) .EQ. 10) THEN
            BODY(I) = 10
          ELSE
            BODY(I) = 129
          ENDIF
          BODY(I+1) = 129
          RETURN
        ENDIF
   10 CONTINUE
 
C  SOMETHING WRONG, TERMINATE THE BODY
      BODY(132) = 129
 
      END
C----------------------------------
C
C  ZSEDTY  - 27 JAN 84
C            TIE LIBRARY
C            STRING SUPPLEMENTARY LIBRARY
C
C  IDENTIFY THE TYPE OF THE SED
C
      INTEGER FUNCTION ZSEDTY(BODY, TYPE)
 
      INTEGER  TYPE, I
      INTEGER  BODY(*)
      INTEGER  ZLOWER
      EXTERNAL ZLOWER
 
      TYPE = -1
      IF(BODY(1) .EQ. 129) GO TO 10
 
      I = 1
      CALL SKIPBL(BODY, I)
      IF(BODY(I) .EQ. 61) THEN
        I = I + 1
        CALL SKIPBL(BODY, I)
        IF(ZLOWER(BODY(I)    ) .EQ. 111   .AND.
     +     ZLOWER(BODY(I + 1)) .EQ. 110)  TYPE = -2
        IF(ZLOWER(BODY(I)    ) .EQ. 111   .AND.
     +     ZLOWER(BODY(I + 1)) .EQ. 102   .AND.
     +     ZLOWER(BODY(I + 2)) .EQ. 102)  TYPE = -3
 
      ELSE
        TYPE = 112
 
      ENDIF
 
   10 CONTINUE
      ZSEDTY = TYPE
 
      END
C----------------------------------
C
C       Z K W L U K  -  Keyword Lookup
C
C       STRING:  IST string to match in KEYTBL. This is automatically
C                converted to lower case.
C
C       KEYTBL:  Table of keywords.
C                format:  KEYTBL(1) = number of keywords in the table
C                         KEYTBL(2-*) = IST strings separated by eos
C
C       result:  1..N = matches keyword number N
C                0    = ambiguous
C                err  = no match found
C
C       Notes: The keyword table must be sorted into alphabetical order
C              for the ambiguity detection to work.  If shorter abbrev-
C              iations are desired, they should be placed at the beginning
C              of the table.
C              The keywords in the table *MUST* be in lower case.
C
 
        INTEGER FUNCTION ZKWLUK(STRING,KEYTBL)
 
        INTEGER STRING(*),KEYTBL(*)
 
        INTEGER I,J,N
 
        EXTERNAL ZTOLOW
 
        CALL ZTOLOW(STRING)
        N=1
        I=1
 100    J=1
 200    IF (STRING(J).EQ.KEYTBL(I+J).AND.STRING(J).NE.129) THEN
            J=J+1
            GOTO 200
        END IF
        IF (STRING(J).EQ.129) THEN
            IF (KEYTBL(I+J).EQ.129 .OR. N.EQ.KEYTBL(1)) THEN
C exact match or last keyword (cannot be ambiguous!)
                ZKWLUK=N
                RETURN
            END IF
 300        J=J+1
            IF (KEYTBL(I+J).NE.129) GOTO 300
            I=I+J
            J=1
 400        IF (STRING(J).EQ.KEYTBL(I+J).AND.STRING(J).NE.129) THEN
                J=J+1
                GOTO 400
            END IF
            IF (STRING(J).EQ.129) THEN
C ambiguous
                ZKWLUK=0
                RETURN
            END IF
C an unambiguous substring
            ZKWLUK=N
            RETURN
        END IF
        N=N+1
        I=I+J
 500    IF (KEYTBL(I).NE.129) THEN
            I=I+1
            GOTO 500
        END IF
        IF (N.LE.KEYTBL(1)) GOTO 100
C no match
        ZKWLUK=-1
        END
C----------------------------------
C
C  ZSPLIT  - 27 JAN 84
C            TIE LIBRARY
C            STRING SUPPLEMENTARY LIBRARY
C
C  SPLIT THE LINE INTO LEFT AND RIGHT HAND SIDES, SEPERATED BY
C  AN EQUALS SIGN.
C
      INTEGER FUNCTION ZSPLIT (LINE, LHS, RHS)
 
      INTEGER  I, J, K, SIGN
      INTEGER  LINE(*), LHS(*), RHS(*)
      INTEGER  INDEXX, LENGTH
      EXTERNAL INDEXX, LENGTH
 
      ZSPLIT = -1
      SIGN   = INDEXX(LINE, 61)
      IF(SIGN .EQ. 0) THEN
        CALL SCOPY(LINE, 1, LHS, 1)
        RHS(1) = 129
        RETURN
      ENDIF
 
      K = 1
      J = 1
      CALL SKIPBL(LINE, K)
 
      DO 10 I = K, SIGN - 1
        LHS(J) = LINE(I)
        J      = J + 1
   10 CONTINUE
 
   20 CONTINUE
      LHS(J) = 129
      IF(LHS(J-1) .EQ. 32) THEN
        J = J - 1
        GO TO 20
      ENDIF
 
      I = SIGN + 1
      CALL SKIPBL(LINE, I)
      CALL SCOPY(LINE, I, RHS, 1)
      J = LENGTH(RHS) + 1
 
   30 CONTINUE
      IF(RHS(J - 1) .EQ. 32) THEN
        J      = J - 1
        RHS(J) = 129
        GO TO 30
      ENDIF
 
      ZSPLIT = -2
 
      END
C----------------------------------
C
C  ZSTRIP  - 26 JAN 84
C            TIE LIBRARY
C            STRING SUPPLEMENTARY LIBRARY
C
C  STRIP ALL BLANKS FROM THE SPECIFIED STRING.
C
      SUBROUTINE ZSTRIP(STRING)
 
      INTEGER FROM, TO
      INTEGER STRING(*)
 
      FROM = 1
      TO   = 1
      CALL SKIPBL(STRING, FROM)
 
      IF(FROM .NE. TO) THEN
        CALL SCOPY(STRING, FROM, STRING, TO)
        FROM = TO
      ENDIF
 
   20 CONTINUE
 
      IF(STRING(FROM) .EQ. 129) THEN
        STRING(TO) = 129
        RETURN
 
      ELSE IF(STRING(FROM) .NE. 32) THEN
        STRING(TO) = STRING(FROM)
        TO         = TO + 1
        FROM       = FROM + 1
 
      ELSE
        CALL SKIPBL(STRING, FROM)
 
      ENDIF
 
      IF(FROM .GT. 134)     RETURN
      GO TO 20
 
      END
C----------------------------------
C
C  ZPACK   - 26 JAN 84
C            TIE LIBRARY
C            STRING SUPPLEMENTARY LIBRARY
C
C  STRIP ALL UNNECESSARY BLANKS FROM THE SPECIFIED STRING. UNNECESSARY
C  BLANKS ARE; LEADING BLANKS, TRAILING BLANKS, MULTIPLE BLANKS (THESE
C  ARE CONVERTED TO SINGLE BLANKS).
C
      SUBROUTINE ZPACK (STRING)
 
      INTEGER FROM, TO
      INTEGER STRING(*)
 
      FROM = 1
      TO   = 1
      CALL SKIPBL(STRING, FROM)
 
      IF(FROM .NE. TO) THEN
        CALL SCOPY(STRING, FROM, STRING, TO)
        FROM = TO
      ENDIF
 
   20 CONTINUE
 
      IF(STRING(FROM) .EQ. 129) THEN
        STRING(TO) = 129
        RETURN
 
      ELSE IF(STRING(FROM) .NE. 32) THEN
        STRING(TO) = STRING(FROM)
        TO         = TO + 1
        FROM       = FROM + 1
 
      ELSE
        STRING(TO) = 32
        CALL SKIPBL(STRING, FROM)
        IF(STRING(FROM) .EQ. 129) STRING(TO) = 129
        TO         = TO + 1
 
      ENDIF
 
      IF(FROM .GT. 134)     RETURN
      GO TO 20
 
      END
C----------------------------------
C
C  ZFTOI   - 26 JAN 84
C            TIE LIBRARY
C            STRING SUPPLEMENTARY LIBRARY
C
C  CONVERT A FORTRAN 77 SUBSTRING TO AN IST STRING
C
      SUBROUTINE ZFTOI(LINE1, FROM, TO, LINE2, FLAG)
 
      INTEGER         I, J, LIMIT, JUNK, FROM, TO
      INTEGER         LINE2(*)
      INTEGER         ZCCTOI
      LOGICAL         FLAG, SKIP
      CHARACTER * (*) LINE1
 
      EXTERNAL        ZCCTOI
      INTRINSIC       LEN, MIN
 
C  SET THE LIMIT OF THE CONVERSION, NO POINT GOING PAST THE END OF THE STRING
      LIMIT = MIN(TO, LEN(LINE1))
      J     = 1
 
      SKIP = .FALSE.
 
C  CONVERSION LOOP
      DO 10 I = FROM, LIMIT
 
C       CONVERT A CHARACTER
        LINE2(J) = ZCCTOI(LINE1(I:I), JUNK)
C
C       IF THE FLAG IS SET TO INTERPRET FORTRAN 77 STRINGS IN THE
C       IST MANNER (VARIABLE LENGTH, TERMINATED BY A PERIOD) THEN
C       IT WILL BE NECESSARY TO CHECK FOR EMBEDDED PERIODS.......
C
        IF(FLAG) THEN
          IF(LINE2(J) .EQ. 46) THEN
            IF(SKIP) THEN
              SKIP = .FALSE.
              GO TO 10
            ELSE
              IF(I.EQ.LIMIT) GO TO 20
              IF(LINE1(I + 1:I + 1) .EQ. '.') THEN
                SKIP = .TRUE.
              ELSE
                GO TO 20
              ENDIF
            ENDIF
          ENDIF
        ENDIF
        J = J + 1
 
   10 CONTINUE
 
C  TERMINATE THE IST STRING
   20 CONTINUE
      LINE2(J) = 129
 
      END
C----------------------------------
C
C  ZITOF   - 26 JAN 84
C            TIE LIBRARY
C            STRING SUPPLEMENTARY LIBRARY
C
C  CONVERT AN IST SUBSTRING TO A FORTRAN 77 STRING
C
C  IF FLAG IS SET .TRUE. THEN THE STRING IS CONVERTED TO AN IST FORMAT
C  FORTRAN 77 STRING, IE: IT IS TERMINATED BY A PERIOD AND ANY INTERNAL
C  PERIODS ARE CONVERTED TO DOUBLE PERIODS.
C
      SUBROUTINE ZITOF(LINE1, FROM, TO, LINE2, FLAG)
 
      INTEGER         I, J, COUNT, FROM, TO, MAXCHR
      INTEGER         LINE1(*)
      LOGICAL         LIMIT, FLAG
      CHARACTER       ZCITOC
      CHARACTER       CH
      CHARACTER * (*) LINE2
      EXTERNAL        ZCITOC
      INTRINSIC       LEN, MOD
 
      J      = 1
      LIMIT  = .FALSE.
      MAXCHR = LEN(LINE2)
 
C  CONVERSION LOOP
      DO 10 I = FROM, TO
 
        IF(LINE1(I) .EQ. 129) LIMIT = .TRUE.
 
        IF(LIMIT) THEN
          IF(FLAG)  GO TO 15
          LINE2(J:J) = ' '
        ELSE
          LINE2(J:J) = ZCITOC(LINE1(I), CH)
          IF(FLAG) THEN
            IF(LINE2(J:J) .EQ. '.') THEN
              J = J + 1
              LINE2(J:J) = '.'
            ENDIF
          ENDIF
        ENDIF
        J = J + 1
        IF(J .GT. MAXCHR) RETURN
   10 CONTINUE
 
 
   15 CONTINUE
      IF(FLAG) THEN
        J = J - 1
        IF(J + 2 .GT. MAXCHR) RETURN
 
        COUNT = 0
   20   CONTINUE
          IF(J - COUNT .LE. 0) GO TO 25
          IF(LINE2(J-COUNT:J-COUNT) .EQ. '.') THEN
            COUNT = COUNT + 1
            GO TO 20
          ENDIF
 
   25   CONTINUE
        IF(MOD(COUNT, 2) .EQ. 0) THEN
          LINE2(J + 1:J + 2) = '. '
        ELSE
          LINE2(J + 1:J + 2) = '..'
        ENDIF
      ENDIF
 
      END
C----------------------------------
C
C  ZTOCAP  - 27 JAN 84
C            TIE LIBRARY
C            STRING SUPPLEMENTARY LIBRARY
C
C  CONVERT AN IST STRING TO UPPER CASE
C
      SUBROUTINE ZTOCAP(STRING)
 
      INTEGER  I
      INTEGER  STRING(*)
      INTEGER  ZUPPER
      EXTERNAL ZUPPER
 
      DO 10 I = 1, 132
        IF(STRING(I) .EQ. 129) RETURN
        STRING(I) = ZUPPER(STRING(I))
   10 CONTINUE
 
      END
C----------------------------------
C
C  ZTERM   - 09 FEB 84
C            TIE LIBRARY
C            STRING SUPPLEMENTARY LIBRARY
C
C  ENSURE THAT A FORTRAN 77 STRING IS TERMINATED WITH AN ODD
C  NUMBER OF PERIODS (AS REQUIRED BY ZMESS AND ZCHOUT).
C
      SUBROUTINE ZTERM(STRING, LENGTH)
 
      INTEGER         I, LENGTH, LIMIT
      CHARACTER * (*) STRING
 
      INTRINSIC       LEN, MIN, MOD
 
C  SET THE LIMIT OF THE CONVERSION, NO POINT GOING PAST THE END OF THE STRING
      LIMIT = MIN(LENGTH, LEN(STRING) - 2)
 
      DO 10 I = LIMIT, 1, -1
        IF(STRING(I:I) .NE. '.') GO TO 20
   10 CONTINUE
 
   20 CONTINUE
C
C  NOW MAKE SURE THAT THERE ARE AN ODD NUMBER OF TRAILING PERIODS.
C
      IF(MOD(LIMIT-I,2) .EQ. 0) THEN
        STRING(LIMIT+1:LIMIT+2) = '. '
 
      ELSE
        STRING(LIMIT+1:LIMIT+1) = ' '
 
      ENDIF
 
      END
C----------------------------------
C
C  ZTOLOW  - 27 JAN 84
C            TIE LIBRARY
C            STRING SUPPLEMENTARY LIBRARY
C
C  CONVERT AN IST STRING TO LOWER CASE
C
      SUBROUTINE ZTOLOW(STRING)
 
      INTEGER  I
      INTEGER  STRING(*)
      INTEGER  ZLOWER
      EXTERNAL ZLOWER
 
      DO 10 I = 1, 132
        IF(STRING(I) .EQ. 129) RETURN
        STRING(I) = ZLOWER(STRING(I))
   10 CONTINUE
 
      END
C----------------------------------
C
C  ZTIMST - 26 JAN 84
C           TIECODE LIBRARY
C           STRING SUPPLEMENTARY LIBRARY
C
      SUBROUTINE ZTIMST(YEAR, MONTH, DAY, HOUR, MINUTE, SECOND, STRING)
 
      INTEGER  YEAR, MONTH, DAY,HOUR, MINUTE, SECOND, I, J, TRIP
      INTEGER  STRING(*), MONS(3, 12),  TEMP(6)
      INTEGER  ITOC
      EXTERNAL ITOC
      SAVE
 
      DATA (MONS(I,  1),I=1,3) /74, 65, 78/
      DATA (MONS(I,  2),I=1,3) /70, 69, 66/
      DATA (MONS(I,  3),I=1,3) /77, 65, 82/
      DATA (MONS(I,  4),I=1,3) /65, 80, 82/
      DATA (MONS(I,  5),I=1,3) /77, 65, 89/
      DATA (MONS(I,  6),I=1,3) /74, 85, 78/
      DATA (MONS(I,  7),I=1,3) /74, 85, 76/
      DATA (MONS(I,  8),I=1,3) /65, 85, 71/
      DATA (MONS(I,  9),I=1,3) /83, 69, 80/
      DATA (MONS(I, 10),I=1,3) /79, 67, 84/
      DATA (MONS(I, 11),I=1,3) /78, 79, 86/
      DATA (MONS(I, 12),I=1,3) /68, 69, 67/
 
 
      DO 20 I = 1, 20
        STRING(I) = 32
   20 CONTINUE
      STRING(21) = 129
      STRING(3) = 58
      STRING(6) = 58
 
      IF((YEAR   .LT. 1000) .OR. (YEAR   .GT. 9999)) RETURN
      IF((MONTH  .LT. 1)    .OR. (MONTH  .GT. 12))   RETURN
      IF((DAY    .LT. 1)    .OR. (DAY    .GT. 31))   RETURN
      IF((HOUR   .LT. 0)    .OR. (HOUR   .GT. 23))   RETURN
      IF((MINUTE .LT. 0)    .OR. (MINUTE .GT. 59))   RETURN
      IF((SECOND .LT. 0)    .OR. (SECOND .GT. 59))   RETURN
 
      TRIP = ITOC(HOUR,  TEMP, 3)
      IF(TRIP .EQ. 1) THEN
        STRING(1) = 48
        STRING(2) = TEMP(1)
      ELSE
        STRING(1) = TEMP(1)
        STRING(2) = TEMP(2)
      ENDIF
      TRIP = ITOC(MINUTE, TEMP, 3)
      IF(TRIP .EQ. 1) THEN
        STRING(4) = 48
        STRING(5) = TEMP(1)
      ELSE
        STRING(4) = TEMP(1)
        STRING(5) = TEMP(2)
      ENDIF
      TRIP = ITOC(SECOND, TEMP, 3)
      IF(TRIP .EQ. 1) THEN
        STRING(7) = 48
        STRING(8) = TEMP(1)
      ELSE
        STRING(7) = TEMP(1)
        STRING(8) = TEMP(2)
      ENDIF
      TRIP = ITOC(DAY, TEMP, 3)
      IF(TRIP .EQ. 1) THEN
        STRING(10) = 48
        STRING(11) = TEMP(1)
      ELSE
        STRING(10) = TEMP(1)
        STRING(11) = TEMP(2)
      ENDIF
 
      DO 10 J = 1, 3
        STRING(12 + J) = MONS(J, MONTH)
   10 CONTINUE
      TRIP = ITOC(YEAR,  TEMP, 5)
      STRING(17) = TEMP(1)
      STRING(18) = TEMP(2)
      STRING(19) = TEMP(3)
      STRING(20) = TEMP(4)
 
      END
C----------------------------------
C
C  ZYESNO  - 06 FEB 84
C            TIE LIBRARY
C            STRING SUPPLEMENTARY LIBRARY
C
C  LOOK FOR A YES/NO STYLE ANSWER FROM THE USER
C
      INTEGER FUNCTION ZYESNO(DEFALT)
 
      INTEGER  DEFALT
      INTEGER  PROMPT(5), ANSWER(134)
      INTEGER  ZLOWER, GETLIN
      EXTERNAL ZLOWER, ZPRMPT, GETLIN
 
      DATA PROMPT/111,107,63,32,129/
 
      ZYESNO = DEFALT
 
      CALL ZPRMPT(PROMPT)
 
      IF(GETLIN(ANSWER, 0) .GT. 1) THEN
        IF(ZLOWER(ANSWER(1)) .EQ. 121) ZYESNO = -2
        IF(ZLOWER(ANSWER(1)) .EQ. 110) ZYESNO = -3
      ENDIF
 
      END
C----------------------------------
C
C  ZSCTOI - 22 MAR 84
C           STRING SUPPLEMENTARY LIBRARY
C
C  SIGNED VERSION OF CTOI
C
C  FUNCTION TO CONVERT AN IST FORMAT STRING TO AN
C  INTEGER. LEADING BLANKS AND TABS ARE IGNORED,
C  THE NUMBER IS TERMINATED BY THE FIRST NON-DIGIT
C  CHARACTER FOUND. NEGATIVE NUMBERS ARE
C  RECOGNIZED. WHITESPACE BETWEEN A MINUS SIGN
C  AND THE DIGITS IS ALLOWED
C  THE CHARACTER POINTER IS RETURNED
C  LOOKING AT THE FIRST NON-DIGIT CHARACTER FOUND.
C
C  IF A MINUS SIGN WITHOUT TRAILING DIGITS IS FOUND
C  THE POINTER IS RETURNED POINTING TO THE MINUS SIGN.
C
      INTEGER FUNCTION ZSCTOI(LINE, POINT)
 
      INTEGER  POINT, TEMP, VAL
      INTEGER  LINE(*)
      INTEGER  CTOI, TYPE
      LOGICAL  FLAG
      EXTERNAL CTOI, TYPE
 
C     SKIP LEADING BLANKS (AND TABS)
      CALL SKIPBL(LINE, POINT)
 
      FLAG = .FALSE.
 
      IF((LINE(POINT) .EQ. 43 ) .OR.
     +   (LINE(POINT) .EQ. 45)) THEN
        TEMP = POINT
        IF(LINE(POINT) .EQ. 45) FLAG = .TRUE.
        TEMP = TEMP + 1
        CALL SKIPBL(LINE, TEMP)
        IF(TYPE(LINE(TEMP)) .NE. 2) THEN
          ZSCTOI = 0
          RETURN
        ENDIF
        POINT = TEMP
      ENDIF
 
      VAL = CTOI(LINE, POINT)
      IF(FLAG) VAL = -VAL
      ZSCTOI = VAL
 
      END
 
